www.gusucode.com > 落叶冰点万能企业网站内容管理系统 V9.1 > 落叶冰点万能企业网站内容管理系统 V9.1\code\admin\adminCollection\Admin_ItemCollecFast.asp
<%@language=vbscript codepage=936 %>
<%
Response.Buffer = True
Server.ScriptTimeOut=999
Response.Expires = -1
Response.ExpiresAbsolute = Now() - 1
Response.Expires = 0
Response.CacheControl = "no-cache"
%>
<!--#include file="inc/conn.asp"-->
<!--#include file="inc/function.asp"-->
<!--#include file="Admin_ChkPurview.asp"-->
<!--#include file="inc/ubbcode.asp"-->
<!--#include file="inc/clsCache.asp"-->
<%
Dim ItemNum,ListNum,PaingNum,NewsSuccesNum,NewsFalseNum
Dim Rs,Sql,RsItem,SqlItem,FoundErr,ErrMsg,ItemEnd,ListEnd
'项目变量
Dim ItemID,ItemName,ChannelID,strChannelDir,ClassID,SpecialID,LoginType,LoginUrl,LoginPostUrl,LoginUser,LoginPass,LoginFalse
Dim ListStr,LsString,LoString,ListPaingType,LPsString,LPoString,ListPaingStr1,ListPaingStr2,ListPaingID1,ListPaingID2,ListPaingStr3,HsString,HoString,HttpUrlType,HttpUrlStr
Dim TsString,ToString,CsString,CoString,DateType,DsString,DoString,AuthorType,AsString,AoString,AuthorStr,CopyFromType,FsString,FoString
Dim CopyFromStr,KeyType,KsString,KoString,KeyStr,NewsPaingType,NPsString,NpoString,NewsPaingStr,NewsPaingHtml
Dim ItemCollecDate,PaginationType,MaxCharPerPage,ReadLevel,Stars,ReadPoint,Hits,UpDateType,UpDateTime,IncludePicYn,DefaultPicYn,OnTop,Elite,Hot
Dim SkinID,TemplateID,Script_Iframe,Script_Object,Script_Script,Script_Div,Script_Class,Script_Span,Script_Img,Script_Font,Script_A,Script_Html,CollecListNum,CollecNewsNum,Passed,SaveFiles,CollecOrder,LinkUrlYn,InputerType,Inputer,EditorType,Editor,ShowCommentLink,Script_Table,Script_Tr,Script_Td
'过滤变量
Dim Arr_Filters,FilterStr,Filteri
'采集相关的变量
Dim ContentTemp,NewsPaingNext,NewsPaingNextCode,Arr_i,NewsUrl,NewsCode
'文章保存变量
Dim ArticleID,Title,Content,Author,CopyFrom,Key,IncludePic,UploadFiles,DefaultPicUrl
'其它变量
Dim LoginData,LoginResult,OrderTemp
Dim Arr_Item,CollecTest,Content_View,CollecNewsAll
Dim StepID
'历史记录
Dim Arr_Histrolys,His_Title,His_CollecDate,His_Result,His_Repeat,His_i
'执行时间变量
Dim StartTime,OverTime
'图片统计
Dim Arr_Images,ImagesNum,ImagesNumAll
'列表
Dim ListUrl,ListCode,NewsArrayCode,NewsArray,ListArray,ListPaingNext
'安装路径
Dim strInstallDir,CacheTemp
strInstallDir=trim(request.ServerVariables("SCRIPT_NAME"))
strInstallDir=left(strInstallDir,instrrev(lcase(strInstallDir),"/")-1)
'strInstallDir=left(strInstallDir,instrrev(lcase(strInstallDir),"/"))
'缓存路径
CacheTemp=Lcase(trim(request.ServerVariables("SCRIPT_NAME")))
CacheTemp=left(CacheTemp,instrrev(CacheTemp,"/"))
CacheTemp=replace(CacheTemp,"\","_")
CacheTemp=replace(CacheTemp,"/","_")
CacheTemp="ansir" & CacheTemp
'数据初始化
CollecListNum=0
CollecNewsNum=0
ArticleID=0
ItemNum=Clng(Trim(Request("ItemNum")))
ListNum=Clng(Trim(Request("ListNum")))
NewsSuccesNum=Clng(Trim(Request("NewsSuccesNum")))
NewsFalseNum=Clng(Trim(Request("NewsFalseNum")))
ImagesNumAll=Clng(Trim(Request("ImagesNumAll")))
ListPaingNext=Trim(Request("ListPaingNext"))
FoundErr=False
ItemEnd=False
ListEnd=False
ErrMsg=""
Call SetCache
If ItemEnd<>True Then
If (ItemNum-1)>Ubound(Arr_Item,2) then
ItemEnd=True
Else
Call SetItems()
End If
End If
If ItemEnd<>True Then
If ListPaingType=0 Then
If ListNum=1 Then
ListUrl=ListStr
Else
ListEnd=True
End If
ElseIf ListPaingType=1 Then
If ListNum=1 Then
ListUrl=ListStr
Else
If ListPaingNext="" or ListPaingNext="$False$" Then
ListEnd=True
Else
ListPaingNext=Replace(ListPaingNext,"{$ID}","&")
ListUrl=ListPaingNext
End If
End If
ElseIf ListPaingType=2 Then
If ListPaingID1>ListPaingID2 then
If (ListPaingID1-ListNum+1)<ListPaingID2 or (ListPaingID1-ListNum+1)<0 Then
Listend=True
Else
ListUrl=Replace(ListPaingStr2,"{$ID}",Cstr(ListpaingID1-ListNum+1))
End if
Else
If (ListPaingID1+ListNum-1)>ListPaingID2 Then
ListEnd=True
Else
ListUrl=Replace(ListPaingStr2,"{$ID}",CStr(ListPaingID1+ListNum-1))
End If
End If
ElseIf ListPaingType=3 Then
ListArray=Split(ListPaingStr3,"|")
If (ListNum-1)>Ubound(ListArray) Then
ListEnd=True
Else
ListUrl=ListArray(ListNum-1)
End If
End If
If ListNum>CollecListNum And CollecListNum<>0 Then
ListEnd=True
End if
End If
If ItemEnd=True Then
ErrMsg="<br>采集任务全部完成"
ErrMsg=ErrMsg & "<br>成功采集： " & NewsSuccesNum & " 条,失败： " & NewsFalseNum & " 条,图片：" & ImagesNumAll & " 张"
Call DelCache()
Else
If ListEnd=True Then
ItemNum=ItemNum+1
ListNum=1
ErrMsg="<br>" & ItemName & " 项目所有列表采集完成，正在整理数据请稍后..."
ErrMsg=ErrMsg & "<meta http-equiv=""refresh"" content=""3;url=Admin_ItemCollecFast.asp?ItemNum=" & ItemNum & "&ListNum=" & ListNum & "&NewsSuccesNum=" & NewsSuccesNum & "&NewsFalseNum=" & NewsFalseNum & "&ImagesNumAll=" & ImagesNumAll & """>"
End If
End If
Call TopItem()
If ItemEnd=True Or ListEnd=True Then
If ItemEnd<>True Then
Call SetCache_His()
End If
Call WriteSucced(ErrMsg)
Else
FoundErr=False
ErrMsg=""
Call StartCollection()
Call FootItem2()
End If
Call FootItem()
Response.Flush()
'关闭数据库链接
Call CloseConn()
Call CloseConnItem()
%>
<%
'==================================================
'过程名：StartCollection
'作 用：开始采集
'参 数：无
'==================================================
Sub StartCollection
'第一次采集时登录
If LoginType=1 And ListNum=1 then
LoginData=UrlEncoding(LoginUser & "&" & LoginPass)
LoginResult=PostHttpPage(LoginUrl,LoginPostUrl,LoginData)
If Instr(LoginResult,LoginFalse)>0 Then
FoundErr=True
ErrMsg=ErrMsg & "<br><li>在登录网站时发生错误，请确保登录信息的正确性！</li>"
End If
End If
If FoundErr<>True then
ListCode=GetHttpPage(ListUrl)
Call GetListPaing()
If ListCode="$False$" Then
FoundErr=True
ErrMsg=ErrMsg & "<br><li>在获取列表：" & ListUrl & "网页源码时发生错误！</li>"
Else
ListCode=GetBody(ListCode,LsString,LoString,False,False)
If ListCode="$False$" Or ListCode="" Then
FoundErr=True
ErrMsg=ErrMsg & "<br><li>在截取：" & ListUrl & "的新闻列表时发生错误！</li>"
End If
End If
End If
If FoundErr<>True Then
NewsArrayCode=GetArray(ListCode,HsString,HoString,False,False)
If NewsArrayCode="$False$" Then
FoundErr=True
ErrMsg=ErrMsg & "<br><li>在分析：" & ListUrl & "新闻列表时发生错误！</li>"
Else
NewsArray=Split(NewsArrayCode,"$Array$")
For Arr_i=0 to Ubound(NewsArray)
If HttpUrlType=1 Then
NewsArray(Arr_i)=Trim(Replace(HttpUrlStr,"{$ID}",NewsArray(Arr_i)))
Else
NewsArray(Arr_i)=Trim(DefiniteUrl(NewsArray(Arr_i),ListUrl))
End If
NewsArray(Arr_i)=CheckUrl(NewsArray(Arr_i))
Next
If CollecOrder=True Then
For Arr_i=0 to Fix(Ubound(NewsArray)/2)
OrderTemp=NewsArray(Arr_i)
NewsArray(Arr_i)=NewsArray(Ubound(NewsArray)-Arr_i)
NewsArray(Ubound(NewsArray)-Arr_i)=OrderTemp
Next
End If
End If
End If
If FoundErr<>True Then
Call TopItem2()
CollecNewsAll=0
For Arr_i=0 to Ubound(NewsArray)
If CollecNewsAll>=CollecNewsNum And CollecNewsNum<>0 Then
Exit For
End If
CollecNewsAll=CollecNewsAll+1
'变量初始化
UploadFiles=""
DefaultPicUrl=""
IncludePic=0
ImagesNum=0
NewsCode=""
FoundErr=False
ErrMsg=""
His_Repeat=False
NewsUrl=NewsArray(Arr_i)
Title=""
PaingNum=1
'………………………………………………
If Response.IsClientConnected Then
Response.Flush
Else
Response.End
End If
'………………………………………………
If CollecTest=False Then
His_Repeat=CheckRepeat(NewsUrl)
Else
His_Repeat=False
End If
If His_Repeat=True Then
FoundErr=True
End If
If FoundErr<>True Then
NewsCode=GetHttpPage(NewsUrl)
If NewsCode="$False$" Then
FoundErr=True
ErrMsg=ErrMsg & "<br>在获取：" & NewsUrl & "新闻源码时发生错误！"
Title="获取网页源码失败"
End If
End If
If FoundErr<>True Then
Title=GetBody(NewsCode,TsString,ToString,False,False)
If Title="$False$" or Title="" then
FoundErr=True
ErrMsg=ErrMsg & "<br>在分析：" & NewsUrl & "的新闻标题时发生错误"
Title="<br>标题分析错误"
End If
If FoundErr<>True Then
Content=GetBody(NewsCode,CsString,CoString,False,False)
If Content="$False$" or Content="" Then
FoundErr=True
ErrMsg=ErrMsg & "<br>在分析：" & NewsUrl & "的新闻正文时发生错误"
Title=Title & "<br>正文分析错误"
End If
End If
If FoundErr<>True Then
'新闻分页
If NewsPaingType=1 Then
NewsPaingNext=GetPaing(NewsCode,NPsString,NPoString,False,False)
NewsPaingNext=FpHtmlEnCode(NewsPaingNext)
Do While NewsPaingNext<>"$False$" And NewsPaingNext<>""
If NewsPaingStr="" or IsNull(NewsPaingStr)=True Then
NewsPaingNext=DefiniteUrl(NewsPaingNext,NewsUrl)
Else
NewsPaingNext=Replace(NewsPaingStr,"{$ID}",NewsPaingNext)
End If
If NewsPaingNext="" or NewsPaingNext="$False$" Then
Exit Do
End If
NewsPaingNextCode=GetHttpPage(NewsPaingNext)
ContentTemp=GetBody(NewsPaingNextCode,CsString,CoString,False,False)
If ContentTemp="$False$" Then
Exit Do
Else
PaingNum=PaingNum+1
Content=Content & NewsPaingHtml & ContentTemp
NewsPaingNext=GetPaing(NewsPaingNextCode,NPsString,NPoString,False,False)
NewsPaingNext=FpHtmlEnCode(NewsPaingNext)
End If
Loop
End If
'过滤
Call Filters
Title=FpHtmlEnCode(Title)
Call FilterScript()
Content=Ubbcode(Content)
End If
End If
'分开写（太长了照顾不过来）
If FoundErr<>True Then
'时间
If UpDateType=0 Then
UpDateTime=Now()
ElseIf UpDateType=1 Then
If DateType=0 then
UpDateTime=Now()
Else
UpDateTime=GetBody(NewsCode,DsString,DoString,False,False)
UpDateTime=FpHtmlEncode(UpDateTime)
UpDateTime=Trim(Replace(UpDateTime," "," "))
If IsDate(UpDateTime)=True Then
UpDateTime=CDate(UpDateTime)
Else
UpDateTime=Now()
End If
End If
ElseIf UpDateType=2 Then
Else
UpDateTime=Now()
End If
'作者
If AuthorType=1 Then
Author=GetBody(NewsCode,AsString,AoString,False,False)
ElseIf AuthorType=2 Then
Author=AuthorStr
Else
Author="佚名"
End If
Author=FpHtmlEncode(Author)
If Author="" or Author="$False$" then
Author="佚名"
Else
If Len(Author)>255 then
Author=Left(Author,255)
End If
End If
'来源
If CopyFromType=1 Then
CopyFrom=GetBody(NewsCode,FsString,FoString,False,False)
ElseIf CopyFromType=2 Then
CopyFrom=CopyFromStr
Else
CopyFrom="不详"
End If
CopyFrom=FpHtmlEncode(CopyFrom)
If CopyFrom="" or CopyFrom="$False$" Then
CopyFrom="不详"
Else
If Len(CopyFrom)>255 Then
CopyFrom=Left(CopyFrom,255)
End If
End If
'关键字
If KeyType=0 Then
Key=Title
Key=CreateKeyWord(Key,2)
ElseIf KeyType=1 Then
Key=GetBody(NewsCode,KsString,KoString,False,False)
Key=FpHtmlEncode(Key)
Key=CreateKeyWord(Key,2)
ElseIf KeyType=2 Then
Key=KeyStr
Key=FpHtmlEncode(Key)
If Len(Key)>253 Then
Key="|" & Left(Key,253) & "|"
Else
Key="|" & Key & "|"
End If
End If
If Key="" or Key="$False$" Then
Key="|新闻|"
End If
'转换图片相对地址为绝对地址/保存
If CollecTest=False And SaveFiles=True then
'If nd_remt_SaveFiles=1 then
Content=ReplaceSaveRemoteFile(Content,strInstallDir,strChannelDir,True,NewsUrl)
Else
Content=ReplaceSaveRemoteFile(Content,strInstallDir,strChannelDir,False,NewsUrl)
End If
'转换swf文件地址
Content=ReplaceSwfFile(Content,NewsUrl)
'图片统计、文章图片属性设置
If UploadFiles<>"" Then
If Instr(UploadFiles,"|")>0 Then
Arr_Images=Split(UploadFiles,"|")
ImagesNum=Ubound(Arr_Images)+1
DefaultPicUrl=Arr_Images(0)
Else
ImagesNum=1
DefaultPicUrl=UploadFiles
End If
If DefaultPicYn=False then
DefaultPicUrl=""
End If
If IncludePicYn=True Then
IncludePic=-1
Else
IncludePic=0
End If
If SaveFiles<>True Then
UploadFiles=""
End If
Else
ImagesNum=0
DefaultPicUrl=""
IncludePic=0
End If
ImagesNumAll=ImagesNumAll+ImagesNum
End If
If FoundErr<>True Then
If CollecTest=False Then
Call SaveArticle
SqlItem="INSERT INTO Histroly(ItemID,ChannelID,ClassID,SpecialID,ArticleID,Title,CollecDate,NewsUrl,Result) VALUES ('" & ItemID & "','" & ChannelID & "','" & ClassID & "','" & SpecialID & "','" & ArticleID & "','" & Title & "','" & Now() & "','" & NewsUrl & "',True)"
ConnItem.Execute(SqlItem)
Content=Replace(Content,"[InstallDir_ChannelDir]",strInstallDir & strChannelDir & "/")
End If
NewsSuccesNum=NewsSuccesNum+1
ErrMsg=ErrMsg & "No:<font color=red>" & NewsSuccesNum+NewsFalseNum & "</font><br>"
ErrMsg=ErrMsg & "新闻标题："
ErrMsg=ErrMsg & "<font color=red>" & Title & "</font><br>"
ErrMsg=ErrMsg & "更新时间：" & UpDateTime & "<br>"
ErrMsg=ErrMsg & "新闻作者：" & Author & "<br>"
ErrMsg=ErrMsg & "新闻来源：" & CopyFrom & "<br>"
ErrMsg=ErrMsg & "采集页面：<a href=" & NewsUrl & " target=_blank>" & NewsUrl & "</a><br>"
ErrMsg=ErrMsg & "其它信息：分页--" & PaingNum & " 页，图片--" & ImagesNum & " 张<br>"
ErrMsg=ErrMsg & "正文预览："
If Content_View=True Then
ErrMsg=ErrMsg & "<br>" & Content
Else
ErrMsg=ErrMsg & "您没有启用正文预览功能"
End If
ErrMsg=ErrMsg & "<br><br>关 键 字：" & Key & ""
Else
NewsFalseNum=NewsFalseNum+1
If His_Repeat=True Then
ErrMsg=ErrMsg & "No:<font color=red>" & NewsSuccesNum+NewsFalseNum & "</font><br>"
ErrMsg=ErrMsg & "目标新闻：<font color=red>"
If His_Result=True Then
ErrMsg=ErrMsg & His_Title
Else
ErrMsg=ErrMsg & NewsUrl
End If
ErrMsg=ErrMsg & "</font> 的记录已存在，不给予采集。<br>"
ErrMsg=ErrMsg & "采集时间：" & His_CollecDate & "<br>"
ErrMsg=ErrMsg & "新闻来源：<a href='" & NewsUrl & "' target=_blank>"&NewsUrl&"</a><br>"
ErrMsg=ErrMsg & "采集结果："
If His_Result=False Then
ErrMsg=ErrMsg & "失败"
ErrMsg=ErrMsg & "<br>失败原因：" & Title
Else
ErrMsg=ErrMsg & "成功"
End If
ErrMsg=ErrMsg & "<br>提示信息：如想再次采集，请先将该新闻的历史记录<font color=red>删除</font><br>"
End If
If CollecTest=False And His_Repeat=False Then
SqlItem="INSERT INTO Histroly(ItemID,ChannelID,ClassID,SpecialID,Title,CollecDate,NewsUrl,Result) VALUES ('" & ItemID & "','" & ChannelID & "','" & ClassID & "','" & SpecialID & "','" & Title & "','" & Now() & "','" & NewsUrl & "',False)"
ConnItem.Execute(SqlItem)
End If
End If
Call ShowMsg(ErrMsg)
Response.Flush()'刷新
Next
Else
Call ShowMsg(ErrMsg)
End If
Response.Write "<table width=""100%"" border=""0"" align=""center"" cellpadding=""2"" cellspacing=""1"">"
Response.Write "<tr>"
Response.write "<td height=""22"" colspan=""2"" align=""left"" class=""tdbg"">"
If CollecTest=False Then
Response.Write "数据整理中，5秒后继续......5秒后如果还没反应请点击 <a href='Admin_ItemCollecFast.asp?ItemNum=" & ItemNum & "&ListNum=" & ListNum+1 & "&NewsSuccesNum=" & NewsSuccesNum & "&NewsFalseNum=" & NewsFalseNum & "&ImagesNumAll=" & ImagesNumAll & "&ListPaingNext=" & ListPaingNext & "'><font color=red>这里</font></a> 继续<br>"
Response.Write "<meta http-equiv=""refresh"" content=""5;url=Admin_ItemCollecFast.asp?ItemNum=" & ItemNum & "&ListNum=" & ListNum+1 & "&NewsSuccesNum=" & NewsSuccesNum & "&NewsFalseNum=" & NewsFalseNum & "&ImagesNumAll=" & ImagesNumAll & "&ListPaingNext=" & ListPaingNext & """>"
Else
Response.Write "<a href='Admin_ItemCollecFast.asp?ItemNum=" & ItemNum & "&ListNum=" & ListNum+1 & "&NewsSuccesNum=" & NewsSuccesNum & "&NewsFalseNum=" & NewsFalseNum & "&ImagesNumAll=" & ImagesNumAll & "&ListPaingNext=" & ListPaingNext & "'><font color=red>请 继 续</font></a>"
End If
Response.Write "</td></tr>"
Response.Write "</table>"
End Sub
'==================================================
'过程名：SetCache
'作 用：存取缓存
'参 数：无
'==================================================
Sub SetCache()
Dim myCache
Set myCache=new clsCache
'项目信息
myCache.name=CacheTemp & "items"
If myCache.valid then
Arr_Item=myCache.value
Else
ItemEnd=True
End If
'过滤信息
myCache.name=CacheTemp & "filters"
If myCache.valid then
Arr_Filters=myCache.value
End If
'历史记录
myCache.name=CacheTemp & "histrolys"
If myCache.valid then
Arr_Histrolys=myCache.value
End If
'其它信息
myCache.name=CacheTemp & "collectest"
If myCache.valid then
CollecTest=myCache.value
Else
CollecTest=False
End If
myCache.name=CacheTemp & "contentview"
If myCache.valid then
Content_View=myCache.value
Else
Content_View=False
End If
Set myCache=Nothing
End Sub
Sub DelCache()
Dim myCache
Set myCache=new clsCache
myCache.name=CacheTemp & "items"
Call myCache.clean()
myCache.name=CacheTemp & "filters"
Call myCache.clean()
myCache.name=CacheTemp & "histrolys"
Call myCache.clean()
myCache.name=CacheTemp & "collectest"
Call myCache.clean()
myCache.name=CacheTemp & "contentview"
Call myCache.clean()
Set myCache=Nothing
End Sub
'==================================================
'过程名：SetItems
'作 用：获取项目信息
'参 数：无
'==================================================
Sub SetItems()
Dim ItemNumTemp
ItemNumTemp=ItemNum-1
ItemID=Arr_Item(0,ItemNumTemp)
ItemName=Arr_Item(1,ItemNumTemp)
ChannelID=Arr_Item(2,ItemNumTemp)'频道ID
strChannelDir=Arr_Item(3,ItemNumTemp)'频道目录
ClassID=Arr_Item(4,ItemNumTemp) '栏目
SpecialID=Arr_Item(5,ItemNumTemp) '专题
LoginType=Arr_Item(9,ItemNumTemp)
LoginUrl=Arr_Item(10,ItemNumTemp) '登录
LoginPostUrl=Arr_Item(11,ItemNumTemp)
LoginUser=Arr_Item(12,ItemNumTemp)
LoginPass=Arr_Item(13,ItemNumTemp)
LoginFalse=Arr_Item(14,ItemNumTemp)
ListStr=Arr_Item(15,ItemNumTemp) '列表地址
LsString=Arr_Item(16,ItemNumTemp) '列表
LoString=Arr_Item(17,ItemNumTemp)
ListPaingType=Arr_Item(18,ItemNumTemp)
LPsString=Arr_Item(19,ItemNumTemp)
LPoString=Arr_Item(20,ItemNumTemp)
ListPaingStr1=Arr_Item(21,ItemNumTemp)
ListPaingStr2=Arr_Item(22,ItemNumTemp)
ListPaingID1=Arr_Item(23,ItemNumTemp)
ListPaingID2=Arr_Item(24,ItemNumTemp)
ListPaingStr3=Arr_Item(25,ItemNumTemp)
HsString=Arr_Item(26,ItemNumTemp)
HoString=Arr_Item(27,ItemNumTemp)
HttpUrlType=Arr_Item(28,ItemNumTemp)
HttpUrlStr=Arr_Item(29,ItemNumTemp)
TsString=Arr_Item(30,ItemNumTemp) '标题
ToString=Arr_Item(31,ItemNumTemp)
CsString=Arr_Item(32,ItemNumTemp) '正文
CoString=Arr_Item(33,ItemNumTemp)
DateType=Arr_Item(34,ItemNumTemp) '作者
DsString=Arr_Item(35,ItemNumTemp)
DoString=Arr_Item(36,ItemNumTemp)
AuthorType=Arr_Item(37,ItemNumTemp) '作者
AsString=Arr_Item(38,ItemNumTemp)
AoString=Arr_Item(39,ItemNumTemp)
AuthorStr=Arr_Item(40,ItemNumTemp)
CopyFromType=Arr_Item(41,ItemNumTemp) '来源
FsString=Arr_Item(42,ItemNumTemp)
FoString=Arr_Item(43,ItemNumTemp)
CopyFromStr=Arr_Item(44,ItemNumTemp)
KeyType=Arr_Item(45,ItemNumTemp) '关键词
KsString=Arr_Item(46,ItemNumTemp)
KoString=Arr_Item(47,ItemNumTemp)
KeyStr=Arr_Item(48,ItemNumTemp)
NewsPaingType=Arr_Item(49,ItemNumTemp) '关键词
NPsString=Arr_Item(50,ItemNumTemp)
NPoString=Arr_Item(51,ItemNumTemp)
NewsPaingStr=Arr_Item(52,ItemNumTemp)
NewsPaingHtml=Arr_Item(53,ItemNumTemp)
PaginationType=Arr_Item(55,ItemNumTemp)
MaxCharPerPage=Arr_Item(56,ItemNumTemp)
ReadLevel=Arr_Item(57,ItemNumTemp)
Stars=Arr_Item(58,ItemNumTemp)
ReadPoint=Arr_Item(59,ItemNumTemp)
Hits=Arr_Item(60,ItemNumTemp)
UpDateType=Arr_Item(61,ItemNumTemp)
UpDateTime=Arr_Item(62,ItemNumTemp)
IncludePicYn=Arr_Item(63,ItemNumTemp)
DefaultPicYn=Arr_Item(64,ItemNumTemp)
OnTop=Arr_Item(65,ItemNumTemp)
Elite=Arr_Item(66,ItemNumTemp)
Hot=Arr_Item(67,ItemNumTemp)
SkinID=Arr_Item(68,ItemNumTemp)
TemplateID=Arr_Item(69,ItemNumTemp)
Script_Iframe=Arr_Item(70,ItemNumTemp)
Script_Object=Arr_Item(71,ItemNumTemp)
Script_Script=Arr_Item(72,ItemNumTemp)
Script_Div=Arr_Item(73,ItemNumTemp)
Script_Class=Arr_Item(74,ItemNumTemp)
Script_Span=Arr_Item(75,ItemNumTemp)
Script_Img=Arr_Item(76,ItemNumTemp)
Script_Font=Arr_Item(77,ItemNumTemp)
Script_A=Arr_Item(78,ItemNumTemp)
Script_Html=Arr_Item(79,ItemNumTemp)
CollecListNum=Arr_Item(80,ItemNumTemp)
CollecNewsNum=Arr_Item(81,ItemNumTemp)
Passed=Arr_Item(82,ItemNumTemp)
SaveFiles=Arr_Item(83,ItemNumTemp)
CollecOrder=Arr_Item(84,ItemNumTemp)
LinkUrlYn=Arr_Item(85,ItemNumTemp)
InputerType=Arr_Item(86,ItemNumTemp)
Inputer=Arr_Item(87,ItemNumTemp)
EditorType=Arr_Item(88,ItemNumTemp)
Editor=Arr_Item(89,ItemNumTemp)
ShowCommentLink=Arr_Item(90,ItemNumTemp)
Script_Table=Arr_Item(91,ItemNumTemp)
Script_Tr=Arr_Item(92,ItemNumTemp)
Script_Td=Arr_Item(93,ItemNumTemp)
If InputerType=1 Then
Inputer=FpHtmlEnCode(Inputer)
Else
Inputer=session("AdminName")
End If
If EditorType=1 Then
Editor=FpHtmlEnCode(Editor)
Else
Editor=session("AdminName")
End If
If IsObjInstalled(fssoo_nd_var_str_x_customx)=False Then
SaveFiles=False
End if
End Sub
'==================================================
'过程名：GetListPaing
'作 用：获取列表下一页
'参 数：无
'==================================================
Sub GetListPaing()
If ListPaingType=1 Then
ListPaingNext=GetPaing(ListCode,LPsString,LPoString,False,False)
ListPaingNext=FpHtmlEnCode(ListPaingNext)
If ListPaingNext<>"$False$" And ListPaingNext<>"" Then
If ListPaingStr1<>"" Then
ListPaingNext=Replace(ListPaingStr1,"{$ID}",ListPaingNext)
Else
ListPaingNext=DefiniteUrl(ListPaingNext,ListUrl)
End If
ListPaingNext=Replace(ListPaingNext,"&","{$ID}")
End If
Else
ListPaingNext="$False$"
End If
End Sub
'==================================================
'过程名：SaveArticle
'作 用：保存文章
'参 数：无
'==================================================
Sub SaveArticle
%>
<!--#include file="save_news_inc.asp"-->
<%
End Sub
'==================================================
'过程名：Filters
'作 用：过滤
'==================================================
Sub Filters()
If IsNull(Arr_Filters)=True or IsArray(Arr_Filters)=False Then
Exit Sub
End if
For Filteri=0 to Ubound(Arr_Filters,2)
FilterStr=""
If Arr_Filters(1,Filteri)=ItemID Or Arr_Filters(10,Filteri)=True Then
If Arr_Filters(3,Filteri)=1 Then'标题过滤
If Arr_Filters(4,Filteri)=1 Then
Title=Replace(Title,Arr_Filters(5,Filteri),Arr_Filters(8,Filteri))
ElseIf Arr_Filters(4,Filteri)=2 Then
FilterStr=GetBody(Title,Arr_Filters(6,Filteri),Arr_Filters(7,Filteri),True,True)
Do While FilterStr<>"$False$"
Title=Replace(Title,FilterStr,Arr_Filters(8,Filteri))
FilterStr=GetBody(Title,Arr_Filters(6,Filteri),Arr_Filters(7,Filteri),True,True)
Loop
End If
ElseIf Arr_Filters(3,Filteri)=2 Then'正文过滤
If Arr_Filters(4,Filteri)=1 Then
Content=Replace(Content,Arr_Filters(5,Filteri),Arr_Filters(8,Filteri))
ElseIf Arr_Filters(4,Filteri)=2 Then
FilterStr=GetBody(Content,Arr_Filters(6,Filteri),Arr_Filters(7,Filteri),True,True)
Do While FilterStr<>"$False$"
Content=Replace(Content,FilterStr,Arr_Filters(8,Filteri))
FilterStr=GetBody(Content,Arr_Filters(6,Filteri),Arr_Filters(7,Filteri),True,True)
Loop
End If
End If
End If
Next
End Sub
'==================================================
'过程名：FilterScript
'作 用：脚本过滤
'==================================================
Sub FilterScript()
If Script_Iframe=True Then
Content=ScriptHtml(Content,"Iframe",1)
End If
If Script_Object=True Then
Content=ScriptHtml(Content,"Object",2)
End If
If Script_Script=True Then
Content=ScriptHtml(Content,"Script",2)
End If
If Script_Div=True Then
Content=ScriptHtml(Content,"Div",3)
End If
If Script_Table=True Then
Content=ScriptHtml(Content,"table",3)
End If
If Script_Tr=True Then
Content=ScriptHtml(Content,"tr",3)
End If
If Script_Td=True Then
Content=ScriptHtml(Content,"td",3)
End If
If Script_Span=True Then
Content=ScriptHtml(Content,"Span",3)
End If
If Script_Img=True Then
Content=ScriptHtml(Content,"Img",3)
End If
If Script_Font=True Then
Content=ScriptHtml(Content,"Font",3)
End If
If Script_A=True Then
Content=ScriptHtml(Content,"A",3)
End If
If Script_Html=True Then
Content=noHtml(Content)
End If
End Sub
'==================================================
'过程名：TopItem
'作 用：显示导航信息
'参 数：无
'==================================================
Sub TopItem()%>
<html>
<head>
<title>新闻采集系统</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<link rel="stylesheet" type="text/css" href="Admin_Style.css">
</head>
<body leftmargin="0" topmargin="0" marginwidth="0" marginheight="0">
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="border">
<tr>
<td height="22" colspan="2" align="center" class="topbg"><strong>采 集 系 统 采 集 管 理</strong></td>
</tr>
</table>
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="border">
<tr class="tdbg">
<td width="65" height="30"><strong>管理导航：</strong></td>
<td height="30"><a href="Admin_ItemStart.asp">管理首页</a> >> 新闻采集</td>
</tr>
</table>
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="border">
<tr>
<td height="22" colspan="2" class="tdbg" aling="center">采集需要一定的时间，请耐心等待，如果网站出现暂时无法访问的情况这是正常的，采集正常结束后即可恢复。
</td>
</tr>
</table>
<%End Sub%>
<%
Sub TopItem2%>
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="border">
<tr>
<td height="22" colspan="2" class="tdbg" aling="left">本次运行：<%=Ubound(Arr_Item,2)+1%> 个项目,正在采集第 <font color=red><%= ItemNum%></font> 个项目 <font color=red><%=ItemName%></font> 的第 <font color=red><%=ListNum%></font> 页列表,该列表待采集新闻 <font color=red><%=Ubound(NewsArray)+1%></font> 条。
<%if CollecNewsNum<>0 Then Response.Write "限制 <font color=red>" & CollecNewsNum & "</font> 条。"%>
<br>采集统计：成功采集--<%=NewsSuccesNum%> 条新闻，失败--<%=NewsFalseNum%> 条，图片--<%=ImagesNumAll%> 张。<a href="Admin_ItemStart.asp">停止采集</a>
</td>
</tr>
</table>
<%StartTime=Timer()%>
<%End Sub%>
<%
'==================================================
'过程名：FootItem
'作 用：显示底部版权等信息
'参 数：无
'==================================================
Sub FootItem()%>
<!--#include file="Admin_ItemFoot.asp"-->
</body>
</html>
<%End Sub%>
<%
'==================================================
'过程名：FootItem2
'作 用：显示该列表采集时间等信息
'参 数：无
'==================================================
Sub FootItem2()
Dim strTemp
OverTime=Timer()
strTemp= "<table width=""100%"" border=""0"" align=""center"" cellpadding=""2"" cellspacing=""1"">"
strTemp=strTemp & "<tr>"
strTemp=strTemp & "<td height=""22"" colspan=""2"" align=""left"" class=""tdbg"">"
strTemp=strTemp & "执行时间：" & CStr(FormatNumber((OverTime-StartTime)*1000,2)) & " 毫秒"
strTemp=strTemp & "</td></tr><br>"
strTemp=strTemp & "</table>"
Response.write strTemp
End Sub
'==================================================
'过程名：ShowMsg
'作 用：显示信息
'参 数：无
'==================================================
Sub ShowMsg(Msg)
Dim strTemp
strTemp= "<table width=""100%"" border=""0"" align=""center"" cellpadding=""2"" cellspacing=""1"">"
strTemp=strTemp & " <tr class='tdbg'>"
strTemp=strTemp & " <td height=""22"" colspan=""2"" align=""left"">"
strTemp=strTemp & Msg
strTemp=strTemp & " </td>"
strTemp=strTemp & " </tr><br>"
strTemp=strTemp & "</table>"
Response.Write StrTemp
End Sub
Function CheckRepeat(strUrl)
CheckRepeat=False
If IsArray(Arr_Histrolys)=True then
For His_i=0 to Ubound(Arr_Histrolys,2)
If Arr_Histrolys(0,His_i)=strUrl Then
CheckRepeat=True
His_Title=Arr_Histrolys(1,His_i)
His_CollecDate=Arr_Histrolys(2,His_i)
His_Result=Arr_Histrolys(3,His_i)
Exit For
End If
Next
End If
End Function
Sub SetCache_His()
'历史记录
SqlItem ="select NewsUrl,Title,CollecDate,Result from Histroly"
Set RsItem=Server.CreateObject("adodb.recordset")
RsItem.Open SqlItem,ConnItem,1,1
If Not RsItem.Eof Then
Arr_Histrolys=RsItem.GetRows()
End If
RsItem.Close
Set RsItem=Nothing
Dim myCache
Set myCache=new clsCache
myCache.name=CacheTemp & "histrolys"
Call myCache.clean()
If IsArray(Arr_Histrolys)=True Then
myCache.add Arr_Histrolys,Dateadd("n",1000,now)
End If
End Sub
%>